home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_gnats.idb / usr / freeware / lib / gnats / contrib / tkgnats / tkquerypr.z / tkquerypr
Encoding:
Tcl/Tk script  |  1999-04-16  |  20.3 KB  |  794 lines
  1. #!/usr/local/bin/wish -file
  2.  
  3. #
  4. # $Id: tkquerypr,v 1.3 1993/11/16 22:19:40 jason Exp $
  5. #
  6.  
  7. set TkGnats(lib) ./; ##TKGNATSLIB##
  8.  
  9. #
  10. # ---- Globals
  11. #
  12.  
  13.  
  14. # This is after the some of the global defns so that the user can 
  15. # override some of them if they wish in their .tkgnatsrc
  16. foreach f { tkpr_library.t reports.t tkprfolder.t } {
  17.     source $TkGnats(lib)/$f
  18. }
  19. proc Msg {args} {
  20.     eval exec msgDialog [wm title .] "" $args &
  21.     schedule_reap
  22. }
  23.  
  24.  
  25. # ID-NUMBER | CATEGORY | SYNOPSIS | CONFIDENTIAL |
  26. # SEVERITY | PRIORITY | RESPONSIBLE | STATE | CLASS |
  27. # SUBMITTER-ID | ARRIVAL-DATE | ORIGINATOR | RELEASE
  28.  
  29. # used when calling sortDialog
  30. set Query(sort_flds) {
  31.     Number    Category    Synopsis    Confidential 
  32.     Severity    Priority    Responsible    State    Class 
  33.     Submitter-Id Arrival-Date    Originator    Release
  34. }
  35. set Query(sort_flgs) {
  36.     "n"        ""        ""          ""
  37.     "n"        "n"        ""          "n"    "" 
  38.     ""        ""        ""        ""
  39. }
  40. # fields that are queryable via query-pr
  41. # XXX Note: Originator is indexed but we treate it like it's not
  42. # that way we can use glob style matches
  43. set Query(indexed_fields) {
  44.     Category Submitter Responsible State Confidential 
  45.     Severity Priority 
  46. }
  47.  
  48. # used when calling sortDialog
  49. set Query(category_pat) "*"
  50. set Query(tmpfile) \
  51.     [format "/tmp/tkquery.%s.[exec date +%d.%H.%M.%S]" $TkGnats(LogName)]
  52.  
  53. #
  54. # numeric --> textual mappings for some query-pr --sql fields
  55. #
  56. set Mappings(State) {open analyzed suspended feedback closed}
  57. set Mappings(Priority) {high medium low}
  58. set Mappings(Severity) {critical serious non-critical}
  59. set Mappings(Class) {sw-bug doc-bug support change-request mistaken duplicate}
  60.  
  61.  
  62. #
  63. # ---- Procedures
  64. #
  65.  
  66. set Query(default_sort_file) [glob -nocomplain -- ~/TkGnats/default-sort]
  67. proc get_default_sort_criteria {} {
  68.     global Query
  69.     check_tkgnats_userdir
  70.     if {$Query(default_sort_file) != ""} {
  71.     if {[file exists $Query(default_sort_file)]} {
  72.         set fin [open $Query(default_sort_file) "r"]
  73.         if {[gets $fin ln] >= 0} {
  74.         if {$ln == ""} {
  75.             Msg "$Query(default_sort_file) is empty??"
  76.         } else {
  77.             return $ln
  78.         }
  79.         } else {
  80.         Msg "$Query(default_sort_file) is empty??"
  81.         }
  82.         close $fin
  83.     }
  84.     }
  85.     return "sort -t| -fb +1 -2 +7n -8 +5n -6 +4n -5 +0n -1"
  86. }
  87. set Query(sort_cmd) [get_default_sort_criteria]
  88. proc set_default_sort_criteria {str} {
  89.     global Query
  90.     check_tkgnats_userdir
  91.     exec rm -f $Query(default_sort_file)
  92.     set fout [open $Query(default_sort_file) "w"]
  93.     puts $fout $str
  94.     close $fout
  95. }
  96.  
  97. proc prid_from_selection {} {
  98.     set s ""
  99.     catch {set s [selection get STRING]}
  100.     set s \
  101.     [lindex [string trim $s "\t\n !@#\$%^&*()_-+=|\\{}\[\]:;'~`<>,.?\""] 0]
  102.     return $s
  103. }
  104.  
  105. proc query_from_selection {} {
  106.     set s [prid_from_selection]
  107.     if {"$s" == ""} {
  108.     Msg "No PR id available in selection"
  109.     return;
  110.     }
  111.     if {[catch {query_cmd $s} errs]} {
  112.     tkerror "Error querying with selection\n<<<$s>>>\n$errs"
  113.     }
  114. }
  115.  
  116. set wstate 1
  117. proc workingMsg {} {
  118.     global wstate TkGnats
  119.     case $wstate 1 {
  120.     .mframe.l configure -bitmap @$TkGnats(lib)/working2.xbm
  121.     set wstate 2
  122.     } 2 {
  123.     .mframe.l configure -bitmap @$TkGnats(lib)/working1.xbm
  124.     set wstate 1
  125.     }
  126.     update idletasks
  127. }
  128.  
  129. proc category_listbox {parent pat} {
  130.     global Category
  131.     # Just a place holder so that Category is defined as an array
  132.     set Category(All) ""
  133.  
  134.     frame $parent.cat 
  135.     pack append $parent $parent.cat {top fillx pady 8}
  136.  
  137.     frame $parent.cat.l
  138.     message $parent.cat.l.msg -anchor w -relief sunken \
  139.     -text "Available Categories:" -aspect 10000
  140.     pack append $parent.cat $parent.cat.l {left}
  141.  
  142.     frame $parent.cat.r
  143.     message $parent.cat.r.msg -anchor w  -relief sunken \
  144.     -text "Selected Categories:" -aspect 10000
  145.     pack append $parent.cat $parent.cat.r {right}
  146.  
  147.     foreach side {l r} {
  148.     set p $parent.cat.$side
  149.     scrollbar $p.sb -command "$p.list yview" -borderwidth 2 \
  150.         -relief sunken
  151.     listbox $p.list -yscroll "$p.sb set" -setgrid 1 \
  152.         -relief sunken -borderwidth 2 \
  153.         -geometry 15x8
  154.     pack append $p \
  155.         $p.msg {top fillx} \
  156.         $p.sb {left filly} \
  157.         $p.list {right expand fill}
  158.     tk_listboxSingleSelect $p.list
  159.     }
  160.  
  161.     eval $parent.cat.l.list insert end [get_categories $pat]
  162.     bind $parent.cat.l.list <B1-ButtonRelease> \
  163.         "category_add_cmd %W %y $parent.cat.r.list"
  164.  
  165.     bind $parent.cat.r.list <B1-ButtonRelease> \
  166.         "category_delete_cmd %W %y $parent.cat.l.list"
  167.  
  168. }
  169.  
  170. proc list_item_switch_cmd {srcw y destw} {
  171.     set idx [$srcw nearest $y]
  172.     set ln [$srcw get $idx]
  173.     if {"$ln" != ""} {
  174.     $srcw delete $idx
  175.     $destw insert end $ln
  176.     }
  177.     return $ln
  178. }
  179.  
  180. proc category_add_cmd {srcw y destw} {
  181.     global Category
  182.     set val [list_item_switch_cmd $srcw $y $destw]
  183.     set Category($val) $val
  184. }
  185.  
  186. proc category_delete_cmd {srcw y destw} {
  187.     global Category
  188.     set val [list_item_switch_cmd $srcw $y $destw]
  189.     if {"$val" != ""} {
  190.     unset Category($val)
  191.     }
  192. }
  193.  
  194. proc query_listbox {p} {
  195.     global Category ""
  196.     set lboxwidth  100
  197.     frame $p.query 
  198.     pack append $p $p.query {top expand fill}
  199.     scrollbar $p.query.sb -command "$p.query.list yview" -borderwidth 2
  200.     label $p.query.label -font fixed -anchor w -text \
  201.  {    Id  Responsible Category         State    Priority Severity     Synopsis}
  202.  
  203.     listbox $p.query.list -font fixed -yscroll "$p.query.sb set" -setgrid 1 \
  204.     -relief sunken -borderwidth 2 -geometry ${lboxwidth}x8
  205.     pack append $p.query \
  206.     $p.query.label {top fillx} \
  207.     $p.query.sb {left filly} \
  208.     $p.query.list {right expand fill}
  209.     tk_listboxSingleSelect $p.query.list
  210.     bind $p.query.list <Enter> "+focus %W"
  211.     bind $p.query.list <Double-Button-1> "editSelection_cmd %W"
  212.  
  213.     bind $p.query.list <Control-l> "%W xview 0"
  214.     bind $p.query.list <KeyRelease-Left> "%W xview 0"
  215.  
  216.     bind $p.query.list <KeyRelease-Right> "%W xview [expr $lboxwidth/2]"
  217.     bind $p.query.list <Control-r> "%W xview [expr $lboxwidth/2]"
  218.  
  219.     return $p.query.list
  220. }
  221.  
  222. #
  223. # ---- Callbacks
  224. #
  225. proc folder_view_cmd {} {
  226.     tkprfolder_dialog .tkprfolder
  227. }
  228.  
  229. proc pridfromsummaryline {ln} {
  230.     scan $ln "%d" prid
  231.     return $prid
  232. }
  233. proc selln {w} {
  234.     set x  [$w curselection]
  235.     if {[llength $x] == 0} {
  236.     return ""
  237.     } else {
  238.     return [$w get [lindex $x 0]]
  239.     }
  240. }
  241.  
  242. proc editSelection_cmd {w} {
  243.     global TkGnats
  244.     set ln [selln $w]
  245.     if {"$ln" != ""} {
  246.     headingMsg "Please Wait..."
  247.     set prid [pridfromsummaryline $ln]
  248.     exec sh -c [format $TkGnats(pr_editor) $prid] &
  249.     schedule_reap
  250.     after 2000 {headingMsg " "}
  251.     }
  252. }
  253.  
  254. proc printSelection_cmd {w} {
  255.     set ln [selln $w]
  256.     if {"$ln" != ""} {
  257.     set prid [pridfromsummaryline $ln]
  258.     fullreport $prid
  259.     }
  260. }
  261.  
  262. proc viewSelection_cmd {w} {
  263.     global Query
  264.     set ln [selln $w]
  265.     if {"$ln" != ""} {
  266.     set prid [pridfromsummaryline $ln]
  267.     exec tkviewpr $prid &
  268.     schedule_reap
  269.     }
  270. }
  271.  
  272. proc previewPrintSelection_cmd {w} {
  273.     global Query TkGnats
  274.     set ln [selln $w]
  275.     if {"$ln" != ""} {
  276.     set prid [pridfromsummaryline $ln]
  277.     set fin [open "|query-pr --full $prid" r]
  278.     set fout [open "|groff -t -ms > $Query(tmpfile)" w]
  279.     formatfullpr $fin $fout
  280.     close $fin
  281.     close $fout
  282.     exec sh -c \
  283. "[format $TkGnats(PSPreviewer) $Query(tmpfile)]\;rm -f $Query(tmpfile)" &
  284.     schedule_reap
  285.     }
  286. }
  287.  
  288. #
  289. # the write_query functions build queries on eof two ways
  290. # - 1 for a regex aware query-pr (querypr then does most of or work)
  291. # - 2 for a nonregex aware query-pr (we have to query eveything and filter
  292. #                    the output ourselves)
  293. #
  294. proc write_query_header {fout procname} {
  295.     global TkGnats Query
  296.     if {$TkGnats(RegexAwareQuerypr)} {
  297.     set Query(query_pr_opts) "-i"
  298.     } else {
  299.     set Query(query_pr_opts) "-i"
  300.     }
  301.     puts $fout "proc $procname \{f\} \{"
  302.     puts $fout "\tupvar 1 \$f flds"
  303.     puts $fout "\tif \{ " nonewline
  304. }
  305.  
  306. proc write_query_qualifier {fout subclauseop type tag lst} {
  307.     global TkGnats Query
  308.     if {([lsearch -exact $Query(indexed_fields) $tag]>=0) && \
  309.                     $TkGnats(RegexAwareQuerypr)} {
  310.     write_regex_query_qualifier $fout $subclauseop $type $tag $lst
  311.     return
  312.     }
  313.     write_dumb_query_qualifier $fout $subclauseop $type $tag $lst
  314. }
  315.  
  316. proc write_regex_query_qualifier {fout subclauseop type tag lst} {
  317.     global Query
  318.     # set AND or OR subclaus operator
  319.     switch -exact -- $subclauseop -and { 
  320.     set subclauseop & 
  321.     } -or {
  322.     set subclauseop |
  323.     }
  324.     set subclausestr ""
  325.     foreach data $lst {
  326.     set data [string trim $data " \n\t"]
  327.     if {"$data" == ""} {
  328.         continue
  329.     }
  330.     # first clause , put in leading option stuff
  331.     if {"$subclausestr" == ""} {
  332.         append Query(query_pr_opts) \
  333.         [format " --%s=" [string tolower $tag]]
  334.     }
  335.     switch -exact -- $type -exact {
  336.         append Query(query_pr_opts) \
  337.         "$subclausestr^[string range $data 0 15]\$"
  338.     } -glob {
  339.         append Query(query_pr_opts) "$subclausestr$data"
  340.     }
  341.     set subclausestr $subclauseop
  342.     }
  343.  
  344.     if {"$subclausestr" == ""} {
  345.     # no clauses were written so just return
  346.     return
  347.     }
  348. }
  349.  
  350. proc write_dumb_query_qualifier {fout subclauseop type tag lst} {
  351.     # set AND or OR subclaus operator
  352.     switch -exact -- $subclauseop -and { 
  353.     set subclauseop && 
  354.     } -or {
  355.     set subclauseop ||
  356.     }
  357.     set subclausestr ""
  358.  
  359.     foreach data $lst {
  360.     set data [string trim $data " \n\t"]
  361.     if {"$data" == ""} {
  362.         continue
  363.     }
  364.     # first clause , put int the leading parens
  365.     if {"$subclausestr" == ""} {
  366.         puts $fout "\t\t" nonewline
  367.         puts $fout "( " nonewline
  368.     }
  369.     switch -exact -- $type -exact {
  370.         puts $fout \
  371.      "$subclausestr ( \$flds($tag) == \[string range \"$data\"\ 0 15\] ) " \
  372.         nonewline
  373.     } -glob {
  374.         puts $fout \
  375.         "$subclausestr ( \[string match \{$data\} \$flds($tag) \] ) " \
  376.         nonewline
  377.     }
  378.     set subclausestr "\\\n\t\t\t$subclauseop"
  379.     }
  380.  
  381.     if {"$subclausestr" == ""} {
  382.     # no clauses were written so just return
  383.     return
  384.     }
  385.  
  386.     puts $fout ") && \\"
  387. }
  388.  
  389. proc write_mtime_qualifier {fout mtime} {
  390.     global TkGnats GNATS_ROOT Query
  391.  
  392.     # A problem here is that there's no primitive 
  393.     # to get the current time.  We'll work around that by
  394.     # calling "file mtime" on the file containing the query (pretty gross,
  395.     # eh?)
  396.  
  397.     set mtime [expr [file mtime $Query(tmpfile)] - $mtime * 24 * 60 * 60]
  398.  
  399.     puts $fout "\t\t( \[file exists $GNATS_ROOT/\$flds(Category)/\$flds(Number)\] && \\"
  400.  
  401.     puts $fout "\t\t  \[file mtime $GNATS_ROOT/\$flds(Category)/\$flds(Number)\] <= $mtime ) && \\"
  402.  
  403. }
  404.  
  405. proc write_query_trailer {fout} {
  406.     global Query
  407.     puts $fout "\t\t1==1 \\\n\t\} " nonewline
  408.     puts $fout "\{\n\t\treturn 1\n\t\}"
  409.     puts $fout "\treturn 0"
  410.     puts $fout \}
  411.  
  412.     puts $fout "set default__opts [list $Query(query_pr_opts)]"
  413. }
  414.  
  415. proc save_query_cmd {{fname ""} {procname ""}} {
  416.     if {$fname == ""} {
  417.     set origp [promptDialog "Enter name of file to save query into"]
  418.     if {"$origp" == ""} {
  419.         headingMsg "Save cancelled"
  420.         return
  421.     }
  422.     set p [string trim $origp " \t\n!;'<>?*%$#"]
  423.     if {"$p" == ""} {
  424.         Msg "'$origp' is not a legal filename"
  425.     }
  426.     set dirname [glob ~]
  427.     set dirname "$dirname/TkGnats"
  428.     exec mkdir -p $dirname
  429.     set fname "$dirname/$p"
  430.     }
  431.     if {"$procname" == ""} {
  432.     set procname ${fname}__query
  433.     }
  434.     set fout [open $fname w]
  435. ####set fout stderr; ###### %%
  436.     write_query_header $fout $procname
  437.  
  438.     # for array globals
  439.     foreach f {
  440.     State Priority Confidential Category Severity Class
  441.     } {
  442.     global $f
  443.     set l {}
  444.     foreach a [array names $f] {
  445.         lappend l [set [set f]($a)]
  446.     }
  447.     write_query_qualifier $fout -or -exact $f $l
  448.     }
  449.  
  450.     # the text field values
  451.     foreach f {
  452.     Responsible Synopsis Days-idle Originator
  453.     } {
  454.     if {"[textget $f]" != ""} {
  455.         switch -exact -- $f Responsible {
  456.         write_query_qualifier $fout -or -exact $f \
  457.             [split [textget $f] " ,|&"]
  458.         } Originator {
  459.         write_query_qualifier $fout -or -glob $f \
  460.             [split [textget $f] " ,|&"]
  461.         } Synopsis {
  462.         # note that we do *not* split on blanks
  463.         write_query_qualifier $fout -and -glob $f \
  464.             [split [textget $f] ",|&"]
  465.         } Days-idle {
  466.         write_mtime_qualifier $fout [textget $f]
  467.         } default {
  468.         Msg "illegal query text field '$f'"
  469.         }
  470.     }
  471.     }
  472.     write_query_trailer $fout
  473.     case $fout stderr {
  474.     } default {
  475.     close $fout
  476.     }
  477.     headingMsg "File written as $fname"
  478. }
  479.  
  480. proc query_cmd {{prid ""}} {
  481.     global lbpath Query Mappings
  482.  
  483.     if {"$prid" == ""} {
  484.     # Build a query from the widget speicfiers
  485.     save_query_cmd $Query(tmpfile) default__query
  486.     source $Query(tmpfile)
  487.     } else {
  488.     # fetch a specific PR
  489.     proc default__query {flds} {return 1}
  490.     }
  491.     headingMsg "Querying with filter '$Query(sort_cmd)' .."
  492.  
  493.     if {$prid == ""} {
  494.     set fin [open "|query-pr $default__opts | $Query(sort_cmd)" r]
  495.     } else {
  496.     set fin [open "|query-pr -i $prid | $Query(sort_cmd)" r]
  497.     }
  498.   
  499.     $lbpath delete 0 end; # clear current list
  500.     set c 0
  501.     while {[gets $fin ln] >= 0} {
  502.     incr c
  503.     if {"$ln" == ""} {
  504.         puts stderr "tkquerypr: warning: line $c empty in query output"
  505.         puts stderr "Have the gnats administrator check the index file"
  506.         puts stderr "for bogus entries"
  507.         continue
  508.     }
  509.  
  510.     #
  511.     # XXX TBD BUG XXX there is a problemo here if the synopsis
  512.     # has a '|' character in it..
  513.     #
  514.     set l [split $ln "|"]
  515.     set llen [llength $l]
  516.     if {$llen != 14} {
  517.         puts stderr "tkquerypr: warning: line \"$ln\" has $llen fields."
  518.         puts stderr "It should have 14 fields. Have the gnats "
  519.         puts stderr "administrator check the index file for bogus entries."
  520.         puts stderr "(Especially for |'s in the Synopsis fields)"
  521.         continue
  522.     }
  523.  
  524.         set flds(Number) [string trimright [lindex $l 0] " "]
  525.         set flds(Category) [string trimright [lindex $l 1] " "]
  526.         set flds(Synopsis) [string trimright [lindex $l 2] " "]
  527.         set flds(Confidential) [string trimright [lindex $l 3] " "]
  528.         set flds(Severity) [string trimright [lindex $l 4] " "]
  529.         set flds(Priority) [string trimright [lindex $l 5] " "]
  530.         set flds(Responsible) [string trimright [lindex $l 6] " "]
  531.         set flds(State) [string trimright [lindex $l 7] " "]
  532.         set flds(Class) [string trimright [lindex $l 8] " "]
  533.         set flds(Submitter-Id) [string trimright [lindex $l 9] " "]
  534.         set flds(Arrival-Date) [string trimright [lindex $l 10] " "]
  535.         set flds(Originator) [string trimright [lindex $l 11] " "]
  536.         set flds(Release) [string trimright [lindex $l 12] " "]
  537.  
  538.     # re-map the numeric fields into text
  539.     foreach f {State Priority Severity Class} {
  540.         set flds($f) [lindex $Mappings($f) [expr "$flds($f) - 1"]]
  541.     }
  542.  
  543.     case $flds(Category) "_*" {
  544.         continue
  545.     } default {
  546.         if {[default__query flds]} {
  547.         set ln [format \
  548.             "%5d %-11s %-16s %-9s %-8s %-12s %s"\
  549.             $flds(Number) \
  550.             $flds(Responsible) \
  551.             $flds(Category) \
  552.             $flds(State) \
  553.             $flds(Priority) \
  554.             $flds(Severity) \
  555.             $flds(Synopsis)]
  556.         $lbpath insert end $ln
  557.         }
  558.     }
  559.     }
  560.  
  561.     exec rm -f $Query(tmpfile)
  562.     headingMsg "Done"
  563.     close $fin
  564. }
  565.  
  566. proc medium_report_from_listbox {ln} {
  567.     global Query
  568.     set prnum [pridfromsummaryline $ln]
  569.     workingMsg
  570.     headingMsg "Doing $prnum..."
  571.     exec sh -c "(query-pr $prnum;echo \"\") >> $Query(tmpfile)"
  572.     return 0
  573. }
  574.  
  575. proc full_report_from_listbox {ln} {
  576.     global Query TkGnats
  577.     set prnum [pridfromsummaryline $ln]
  578.     workingMsg
  579.     headingMsg "Doing $prnum..."
  580.     exec sh -c "query-pr --full $prnum | $TkGnats(PlainPrintSpooler)"
  581.     ## fullreport $no; # this is quite a hog...
  582.     return 0
  583. }
  584. proc perform_query_cmd {{print _list_}} {
  585.     global lbpath Query TkGnats
  586.     headingMsg "Working.."
  587.  
  588.     case $print {_list_} {
  589.     query_cmd
  590.     } summary_preview {
  591.     write_listbox $lbpath $Query(tmpfile)
  592.     summary_report $Query(tmpfile) preview
  593.     exec rm -f $Query(tmpfile)
  594.     } summary {
  595.     write_listbox $lbpath $Query(tmpfile)
  596.     summary_report $Query(tmpfile)
  597.     exec rm -f $Query(tmpfile)
  598.     } full {
  599.     foreach_listbox $lbpath full_report_from_listbox
  600.     } medium {
  601.     exec rm -f $Query(tmpfile)
  602.     foreach_listbox $lbpath medium_report_from_listbox
  603.     exec sh -c "cat $Query(tmpfile) | $TkGnats(PlainPrintSpooler)"
  604.     exec rm -f $Query(tmpfile)
  605.     }
  606.     headingMsg "Done"
  607.     return
  608. }
  609.  
  610. #
  611. # filter procs
  612. #
  613. proc filter_get_list {dir} {
  614.     if {![file isdirectory $dir]} {
  615.     tkerror "$dir is not a directory"
  616.     } else {
  617.     return [glob -nocomplain -- $dir/*]
  618.     }
  619. }
  620. proc filter_assemble_menuitems {m dir lboxpath} {
  621.     set flist [filter_get_list $dir]
  622.     foreach f $flist {
  623.     $m add command -label [file tail $f] -command "filter_run $f $lboxpath"
  624.     }
  625. }
  626. proc filter_run {filtname lbox} {
  627.     global GNATS_ROOT
  628.     set lboxsize [$lbox size]
  629.     set filter [open "|$filtname" w]
  630.     for {set i 0} {$i<$lboxsize} {incr i} {
  631.     set ln [$lbox get $i]
  632.     scan $ln "%d %s %s" prid responsible category
  633.     puts $filter  "$GNATS_ROOT/$category/$prid $ln"
  634.     }
  635.     close $filter
  636. }
  637.  
  638. proc set_query_sorting_cmd {} {
  639.     global Query
  640.     if {[ catch { set rval \
  641.     [exec sortDialog $Query(sort_flds) $Query(sort_flgs)]} errs ]} {
  642.     headingMsg "Sort dialog cancelled. $errs"
  643.     return
  644.     }
  645.     set Query(sort_cmd) $rval
  646.     set_default_sort_criteria $rval
  647. }
  648.  
  649.  
  650. proc exit_cmd {} {
  651.     Exit 0
  652. }
  653.  
  654. #
  655. # ---- Process args
  656. #
  657. proc usage {{exitFlg ""} {str ""}} {
  658.     if {"$str" != ""} {
  659.     puts stderr "tkquerypr: $str"
  660.     }
  661.     puts stderr "tkquerypr usage:\n"
  662.     foreach ln {
  663.     {tkquerypr [-categories 'pattern']}
  664.     } {
  665.     puts stderr "\t$ln"
  666.     }
  667.     if {"$exitFlg" != ""} {
  668.     Exit $exitFlg
  669.     }
  670. }
  671. proc process_args {} {
  672.     global argc argv Query
  673.     if {$argc != 0} {
  674.     if {$argc%2 != 0} {
  675.         usage 1
  676.     }
  677.     for {set x 0} {$x<$argc} {incr x 2} {
  678.         set opt [lindex $argv $x]
  679.         set val [lindex $argv [expr $x+1]]
  680.         case $opt "-categories" {
  681.         set Query(category_pat) $val
  682.         } default {
  683.         usage 1 "illegal option pair '$opt $val'"
  684.         }
  685.     }
  686.     }
  687. }
  688.  
  689. process_args
  690.  
  691. #
  692. # ---- Build widgets
  693. #
  694. frame .mframe -borderwidth 1 -relief raised
  695. button .mframe.l -bitmap @$TkGnats(lib)/working1.xbm \
  696.     -command query_from_selection
  697. # bind .mframe.l <B1-ButtonRelease> "query_from_selection"
  698. message .mframe.msg -aspect 10000 
  699. pack append .mframe .mframe.l {left} .mframe.msg {left fillx}
  700. pack append . .mframe {top fillx}
  701.  
  702. frame .eflds
  703. radiobar_frame .eflds .eflds.lb
  704. checkbar .eflds.lb state State {open analyzed feedback closed suspended} All
  705. checkbar .eflds.lb priority Priority {high medium low} All
  706. checkbar .eflds.lb confidential Confidential {yes no} All
  707. checkbar .eflds.lb severity Severity {non-critical serious critical} All
  708. checkbar .eflds.lb class Class {sw-bug doc-bug change-request support mistaken duplicate} All
  709.  
  710. frame .eflds.clb
  711. set cbpath [category_listbox .eflds.clb $Query(category_pat)]
  712. pack append .eflds .eflds.lb {left} .eflds.clb {right padx 8}
  713. pack append . .eflds {top fillx}
  714.  
  715. singletext Responsible 40 ""
  716. singletext Originator 40 ""
  717. singletext Synopsis 40 ""
  718. singletext Days-idle 10 ""
  719.  
  720. frame .qlb
  721. pack append . .qlb {expand fill}
  722. set lbpath [query_listbox .qlb]
  723.  
  724. frame .menu -relief raised -borderwidth 2
  725. pack before .qlb .menu {top fillx}
  726.  
  727. # 
  728. # If there is a filter directory, make a filters menu
  729. #
  730. if {[file isdirectory $TkGnats(FilterDirectory)]} {
  731.     menubutton .menu.filters -text "filters" \
  732.     -menu .menu.filters.m -underline 0
  733.     menu .menu.filters.m
  734.     filter_assemble_menuitems .menu.filters.m $TkGnats(FilterDirectory) $lbpath
  735.     pack append .menu .menu.filters left
  736. }
  737.  
  738. ##
  739. menubutton .menu.print -text "print" -menu .menu.print.m -underline 0
  740. menu .menu.print.m
  741. if {[info exists TkGnats(PSPreviewer)]} {
  742.     set x summary_preview
  743.     .menu.print.m add command -label $x -command "perform_query_cmd $x"
  744. }
  745. foreach x { summary medium full } {
  746.     .menu.print.m add command -label $x -command "perform_query_cmd $x"
  747. }
  748. ##
  749. menubutton .menu.query -text "query" -menu .menu.query.m -underline 0
  750. menu .menu.query.m
  751. foreach x { perform_query set_query_sorting} {
  752.     .menu.query.m add command -label $x -command ${x}_cmd
  753. }
  754. ##
  755. menubutton .menu.folders -text "folders" -menu .menu.folders.m -underline 0
  756. menu .menu.folders.m
  757. foreach x {view} {
  758.     .menu.folders.m add command -label $x -command folder_${x}_cmd
  759. }
  760. ##
  761. menubutton .menu.sel -text "selection" -menu .menu.sel.m -underline 0
  762. menu .menu.sel.m
  763. foreach x {viewSelection editSelection printSelection } {
  764.     .menu.sel.m add command -label $x -command "${x}_cmd $lbpath"
  765. }
  766. if {[info exists TkGnats(PSPreviewer)]} {
  767.     set x previewPrintSelection
  768.     .menu.sel.m add command -label $x -command "${x}_cmd $lbpath"
  769. }
  770.  
  771. ##
  772. menubutton .menu.exit -text "exit" -menu .menu.exit.m -underline 0
  773. menu .menu.exit.m
  774. foreach x { exit } {
  775.     .menu.exit.m add command -label $x -command ${x}_cmd
  776. }
  777.  
  778. foreach x {
  779.     print query folders sel 
  780. } {
  781.     pack append .menu .menu.$x left
  782. }
  783.  
  784. pack append .menu .menu.exit right
  785. tk_menuBar .menu .menu.print menu.query
  786. tk_bindForTraversal .
  787.  
  788. proc headingMsg {s} {
  789.     .mframe.msg configure -text $s
  790.     update
  791. }
  792. wm iconbitmap . @$TkGnats(lib)/tkquerypr.xbm
  793. wm iconname . "$TkGnats(LogName)'s tkquerypr"
  794.